home *** CD-ROM | disk | FTP | other *** search
/ Aminet 24 / Aminet 24 (1998)(GTI - Schatztruhe)[!][Apr 1998].iso / Aminet / dev / lang / PPCcforth.lha / PPCcforth / forth.c < prev    next >
C/C++ Source or Header  |  1985-12-27  |  14KB  |  565 lines
  1. /*
  2.  * forth.c
  3.  * 
  4.  * Portable FORTH interpreter in C
  5.  *
  6.  * Author: Allan Pratt, Indiana University (iuvax!apratt)
  7.  *         Spring, 1984
  8.  * References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
  9.  *         in the world...)
  10.  *
  11.  * This program is intended to be compact, portable, and pretty complete.
  12.  * It is also intended to be in the public domain, and distribution should
  13.  * include this notice to that effect.
  14.  *
  15.  * This file contains the support code for all interpreter functions.
  16.  * the file prims.c contains code for the C-coded primitives, and the
  17.  * file forth.h connects the two with definitions.
  18.  *
  19.  * The program nf.c generates a new forth.core file from the dictionary
  20.  * forth.dict, using common.h to tie it together with this program.
  21.  */
  22.  
  23.  
  24. #include <stdio.h>
  25. #ifndef AMIGA
  26. #include <signal.h>
  27. #endif
  28.  
  29. #include <ctype.h>    /* only for isxdigit */
  30.  
  31. #include "common.h"
  32.  
  33. #include "forth.h"
  34.  
  35. #include "prims.h"    /* macro-defined primitives */
  36.  
  37. /* declare globals which are defined in forth.h */
  38.  
  39. unsigned short csp, rsp, ip, w;
  40. short *mem;
  41. int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
  42. int nobuf;
  43. FILE *blockfile;
  44. long bfilesize;
  45. char *bfilename;    /* block file name (change with -f ) */
  46. char *cfilename;    /* core file name  (change with -l ) */
  47. char *sfilename;    /* save file name  (change with -s ) */
  48.  
  49. /*
  50.              ----------------------------------------------------
  51.                                SYSTEM FUNCTIONS
  52.              ----------------------------------------------------
  53. */
  54.  
  55. errexit(s,p1,p2)        /* An error occurred -- clean up (?) and
  56.                    exit. */
  57. {
  58.     printf(s,p1,p2);
  59.     printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
  60.     fflush(stdout);
  61.     memdump();
  62.     puts("done.");
  63.     exit(1);
  64. }
  65.  
  66. Callot (n)            /* allot n words in the dictionary */
  67. short n;
  68. {
  69.     unsigned newsize;
  70.  
  71.     mem[DP] += n;            /* move DP */
  72.     if (mem[DP] + GULPFRQ > mem[LIMIT]) {    /* need space */
  73.     newsize = mem[DP] + GULPSIZE;
  74.     if (newsize > MAXMEM && MAXMEM)
  75.         errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);
  76. #ifdef AMIGA
  77.         /*
  78.          * Fake realloc by doing a malloc and copy to the new area.
  79.          * Since we are always just growing the area, this should work.
  80.          * Note that this has the disadvantage of requiring at least 2N
  81.      * bytes to grow an area of N bytes.
  82.          */
  83.         {
  84.             register char *new, *out;
  85.             register char *in = mem;
  86.             register int count = mem[LIMIT];
  87.             new = out = (short *) malloc ((char *)mem, newsize*sizeof(*mem));
  88.         if (new == NULL)
  89.             errexit("REALLOC FAILED\n");
  90.             while (count-- > 0) {
  91.             *out++ = *in++;
  92.         }
  93.             free (mem);
  94.             mem = new;
  95.         }
  96. #else
  97.     mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
  98.     if (mem == NULL)
  99.         errexit("REALLOC FAILED\n");
  100. #endif    /* AMIGA */
  101.     mem[LIMIT] = newsize;
  102.     }
  103. }
  104.  
  105. push(v)            /* push value v to cstack */
  106. short v;
  107. {
  108.     if (csp <= TIB_END)
  109.     errexit("PUSH TO FULL CALC. STACK\n");
  110.     mem[--csp] = v;
  111. }
  112.  
  113. short pop()            /* pop a value from comp. stack, and return
  114.                    it as the value of the function */
  115. {
  116.     if (csp >= INITS0) {
  117.     puts("Empty Stack!");
  118.     return 0;
  119.     }
  120.     return (mem[csp++]);
  121. }
  122.  
  123. rpush(v)
  124. short v;
  125. {
  126.     if (rsp <= INITS0)
  127.     errexit("PUSH TO FULL RETURN STACK");
  128.     mem[--rsp] = v;
  129. }
  130.  
  131. short rpop()
  132. {
  133.     if (rsp >= INITR0)
  134.     errexit("POP FROM EMPTY RETURN STACK!");
  135.     return (mem[rsp++]);
  136. }
  137.  
  138. pkey()            /* (KEY) -- wait for a key & return it */
  139. {
  140.     int c;
  141.     if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
  142.     return(c);
  143. }
  144.  
  145. pqterm()            /* (?TERMINAL): 
  146.                     return true if BREAK has been hit */
  147. {
  148.     if (qtermflag) {
  149.         push(TRUE);
  150.         qtermflag = FALSE;    /* this influences ^C handling */
  151.     }
  152.     else push(FALSE);
  153. }
  154.  
  155. pemit()                /* (EMIT): c --    emit a character */
  156. {
  157.     putchar(pop() & 0x7f);    /* stdout is unbuffered */
  158. }
  159.  
  160. next()            /* instruction processor: control goes here
  161.                    almost right away, and cycles through here
  162.                    until you leave. */
  163.  
  164. /* 
  165.  * This is the big kabloona. What it does is load the value at mem[ip]
  166.  * into w, increment ip, and invoke prim. number w. This implies that
  167.  * mem[ip] is the CFA of a word. What's in the CF of a word is the number
  168.  * of the primitive which should be executed. For a word written in FORTH,
  169.  * that primitive is "docol", which pushes ip to the return stack, then
  170.  * uses w+2 (the PFA of the word) as the new ip.  See "interp.doc" for
  171.  * more.
  172.  */
  173.  
  174. /*
  175.  * There is an incredible hack going on here: the SPECIAL CASE mentioned in
  176.  * the code is for the word EXECUTE, which must set W itself and jump INSIDE
  177.  * the "next" loop, by-passing the first instruction. This has been made a
  178.  * special case: if the primitive to execute is zero, the special case is
  179.  * invoked, and the code for EXECUTE is put right in the NEXT loop. For this
  180.  * reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
  181.  */
  182. {
  183.     short p;
  184.     
  185.     while (1) {
  186.     if (forceip) {        /* force ip to this value -- used by sig_int */
  187.         ip = forceip;
  188.         forceip = FALSE;
  189.     }
  190. #ifdef TRACE
  191.     if (trace) dotrace();
  192. #endif TRACE
  193.  
  194. #ifdef BREAKPOINT
  195.     if (breakenable && ip == breakpoint) dobreak();
  196. #endif BREAKPOINT
  197.  
  198.     w = mem[ip];
  199.     ip++;
  200.                 /* w, mem, and ip are all global. W is now
  201.                    a POINTER TO the primitive number to 
  202.                    execute, and ip points to the NEXT thread to
  203.                    follow. */
  204.  
  205. next1:                /* This is for the SPECIAL CASE */
  206.     p = mem[w];        /* p is the actual number of the primitive */
  207.     if (p == 0) {        /* SPECIAL CASE FOR EXECUTE! */
  208.         w = pop();        /* see above for explanation */
  209.         goto next1;
  210.     }
  211.     /* else */
  212.     switch(p) {
  213.     case LIT    :  lit(); break;
  214.     case BRANCH    :  branch(); break;
  215.     case ZBRANCH    :  zbranch(); break;
  216.     case PLOOP    :  ploop(); break;
  217.     case PPLOOP    :  pploop(); break;
  218.     case PDO    :  pdo(); break;
  219.     case I        :  i(); break;
  220.     case R        :  r(); break;
  221.     case DIGIT    :  digit(); break;
  222.     case PFIND    :  pfind(); break;
  223.     case ENCLOSE    :  enclose(); break;
  224.     case KEY    :  key(); break;
  225.     case PEMIT    :  pemit(); break;
  226.     case QTERMINAL    :  qterminal(); break;
  227.     case CMOVE    :  cmove(); break;
  228.     case USTAR    :  ustar(); break;
  229.     case USLASH    :  uslash(); break;
  230.     case AND    :  and(); break;
  231.     case OR        :  or(); break;
  232.     case XOR    :  xor(); break;
  233.     case SPFETCH    :  spfetch(); break;
  234.     case SPSTORE    :  spstore(); break;
  235.     case RPFETCH    :  rpfetch(); break;
  236.     case RPSTORE    :  rpstore(); break;
  237.     case SEMIS    :  semis(); break;
  238.     case LEAVE    :  leave(); break;
  239.     case TOR    :  tor(); break;
  240.     case FROMR    :  fromr(); break;
  241.     case ZEQ    :  zeq(); break;
  242.     case ZLESS    :  zless(); break;
  243.     case PLUS    :  plus(); break;
  244.     case DPLUS    :  dplus(); break;
  245.     case MINUS    :  minus(); break;
  246.     case DMINUS    :  dminus(); break;
  247.     case OVER    :  over(); break;
  248.     case DROP    :  drop(); break;
  249.     case SWAP    :  swap(); break;
  250.     case DUP    :  dup(); break;
  251.     case TDUP    :  tdup(); break;
  252.     case PSTORE    :  pstore(); break;
  253.     case TOGGLE    :  toggle(); break;
  254.     case FETCH    :  fetch(); break;
  255.     case CFETCH    :  cfetch(); break;
  256.     case TFETCH    :  tfetch(); break;
  257.     case STORE    :  store(); break;
  258.     case CSTORE    :  cstore(); break;
  259.     case TSTORE    :  tstore(); break;
  260.     case DOCOL    :  docol(); break;
  261.     case DOCON    :  docon(); break;
  262.     case DOVAR    :  dovar(); break;
  263.     case DOUSE    :  douse(); break;
  264.     case SUBTRACT    :  subtract(); break;
  265.     case EQUAL    :  equal(); break;
  266.     case NOTEQ    :  noteq(); break;
  267.     case LESS    :  less(); break;
  268.     case ROT    :  rot(); break;
  269.     case DODOES    :  dodoes(); break;
  270.     case DOVOC    :  dovoc(); break;
  271.     case ALLOT    :  allot(); break;
  272.     case PBYE    :  pbye(); break;
  273.     case TRON    :  tron(); break;
  274.     case TROFF    :  troff(); break;
  275.     case DOTRACE    :  dotrace(); break;
  276.     case PRSLW    :  prslw(); break;
  277.     case PSAVE    :  psave(); break;
  278.     case PCOLD    :  pcold(); break;
  279.     default        :  errexit("Bad execute-code %d\n",p); break;
  280.     }
  281.     }
  282. }
  283.  
  284. dotrace()
  285. {
  286.     short worka, workb, workc;
  287.     putchar('\n');
  288.     if (tracedepth) {        /* show any stack? */
  289.         printf("sp: %04x (", csp);
  290.         worka = csp;
  291.         for (workb = tracedepth; workb; workb--)
  292.             printf("%04x ",(unsigned short) mem[worka++]);
  293.         putchar(')');
  294.     }
  295.     printf(" ip=%04x ",ip);
  296.  
  297.     if (mem[R0]-rsp < RS_SIZE && mem[R0] - rsp > 0) /* if legal rsp */
  298.         for (worka = mem[R0]-rsp; worka; worka--) { /* indent */
  299.         putchar('>');
  300.         putchar(' ');
  301.         }
  302.     worka = mem[ip] - 3;        /* this is second-to-last letter, or
  303.                        the count